home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / grp_vwrs / quikview / global.bas < prev    next >
BASIC Source File  |  1995-06-04  |  20KB  |  510 lines
  1. Global BMPArray() As String
  2. Global ImagePointer As Integer
  3. Global Const OffsetX = 30
  4. Global Const OffsetY = 315
  5.  
  6. Type PALETTEENTRY
  7.     peRed As String * 1
  8.     peGreen As String * 1
  9.     peBlue As String * 1
  10.     peFlags As String * 1
  11. End Type
  12.  
  13. Type LOGPALETTE
  14.     palVersion As Integer
  15.     palNumEntries As Integer
  16.     palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
  17. End Type
  18.  
  19. Type BITMAPINFOHEADER
  20.    biSize As Long
  21.    biWidth As Long
  22.    biHeight As Long
  23.    biPlanes As Integer
  24.    biBitCount As Integer
  25.    biCompression As Long
  26.    biSizeImage As Long
  27.    biXPelsPerMeter As Long
  28.    biYPelsPerMeter As Long
  29.    biClrUsed As Long
  30.    biClrImportant As Long
  31. End Type
  32.  
  33. Type BITMAPINFO
  34.    bmiHeader As BITMAPINFOHEADER
  35.    bmiColors(255) As PALETTEENTRY 'Enough for 256 colors
  36. End Type
  37.  
  38. Type RECT
  39.     Left As Integer
  40.     Top As Integer
  41.     Right As Integer
  42.     Bottom As Integer
  43. End Type
  44.  
  45. Global Const PIXELS = 3
  46. Global Const SRCCOPY = &HCC0020
  47. Global Const BI_RGB = 0
  48. Global Const DIB_RGB_COLORS = 0
  49. Global Const GMEM_MOVEABLE = 2
  50. Global Const RASTERCAPS = 38
  51. Global Const RC_STRETCHDIB = &H2000
  52. Global Const RC_PALETTE = &H100
  53. Global Const PLANES = 14
  54. Global Const BITSPIXEL = 12
  55. Global Const SIZEPALETTE = 104
  56. Global Const PD_PRINTSETUP = &H40&
  57.  
  58. 'The following declares must each be entered on a single line:
  59. Declare Function CreateCompatibleDC Lib "GDI" (ByVal hDC As Integer) As Integer
  60. Declare Function CreateCompatibleBitmap Lib "GDI" (ByVal hDC As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
  61. Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer, ByVal iCapabilitiy As Integer) As Integer
  62. Declare Function GetSystemPaletteEntries Lib "GDI" (ByVal hDC As Integer, ByVal wStartIndex As Integer, ByVal wNumEntries As Integer, lpPaletteEntries As PALETTEENTRY) As Integer
  63. Declare Function CreatePalette Lib "GDI" (lpLogPalette As LOGPALETTE) As Integer
  64. Declare Function SelectObject Lib "GDI" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
  65. Declare Function BitBlt Lib "GDI" (ByVal hDCDest As Integer, ByVal XDest As Integer, ByVal YDest As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hDCSrc As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwROP As Long) As Integer
  66. Declare Function GetDIBits Lib "GDI" (ByVal hDC As Integer, ByVal hBitmap As Integer, ByVal nStartScan As Integer, ByVal nNumScans As Integer, ByVal lpBits As Long, BITMAPINFO As BITMAPINFO, ByVal wUsage As Integer) As Integer
  67. Declare Function StretchDIBits Lib "GDI" (ByVal hDC As Integer, ByVal DestX As Integer, ByVal DestY As Integer, ByVal wDestWidth As Integer, ByVal wDestHeight As Integer, ByVal SrcX As Integer, ByVal SrcY As Integer, ByVal wSrcWidth As Integer, ByVal wSrcHeight As Integer, ByVal lpBits As Long, BitsInfo As BITMAPINFO, ByVal wUsage As Integer, ByVal dwROP As Long) As Integer
  68. Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
  69. Declare Function DeleteDC Lib "GDI" (ByVal hDC As Integer) As Integer
  70. Declare Function GlobalAlloc Lib "KERNEL" (ByVal wFlags As Integer, ByVal lMem As Long) As Integer
  71. Declare Function GlobalLock Lib "KERNEL" (ByVal hMem As Integer) As Long
  72. Declare Function GlobalUnlock Lib "KERNEL" (ByVal hMem As Integer) As Integer
  73. Declare Function GlobalFree Lib "KERNEL" (ByVal hMem As Integer) As Integer
  74. Declare Function SelectPalette Lib "USER" (ByVal hDC As Integer, ByVal hPalette As Integer, ByVal bForceBackground As Integer) As Integer
  75. Declare Function RealizePalette Lib "USER" (ByVal hDC As Integer) As Integer
  76. Declare Function GetWindowDC Lib "USER" (ByVal hWnd As Integer) As Integer
  77. Declare Function GetWindowRect Lib "USER" (ByVal hWnd As Integer, lpRect As RECT) As Integer
  78. Declare Function ReleaseDC Lib "USER" (ByVal hWnd As Integer, ByVal hDC As Integer) As Integer
  79.  
  80. ' Error Constants:
  81. ' Device does not support StretchDIBits.
  82. Global Const ERR_DEVSTRETCHDIB = 11105
  83. ' Palette is not 256-color palette.
  84. Global Const ERR_PALSIZE = 11106
  85. ' Unable to create device context.
  86. Global Const ERR_CREATEMEMDC = 11107
  87. ' Unable to create bitmap.
  88. Global Const ERR_CREATEBMP = 11108
  89. ' Unable to retrieve system palette.
  90. Global Const ERR_GETPALETTE = 11109
  91. ' Unable to create a new palette.
  92. Global Const ERR_CREATEPAL = 11120
  93. ' Unable to copy bitmap to memory.
  94. Global Const ERR_BITBLT = 11110
  95. ' Unable to allocate memory for DIB bits.
  96. Global Const ERR_BITMEM = 11111
  97. ' Unable to lock DIB bits memory.
  98. Global Const ERR_LOCKBITMEM = 11112
  99. ' Unable to get DIB bits.
  100. Global Const ERR_GETDIB = 11113
  101. ' Unable to copy bitmap to destination.
  102. Global Const ERR_STRETCHDIB = 11114
  103. ' Unable to unlock DIB bits memory.
  104. Global Const ERR_UNLOCKMEM = 11115
  105. ' Unable to free DIB bits memory.
  106. Global Const ERR_FREEMEM = 11116
  107. ' Unable to select palette.
  108. Global Const ERR_SELPAL = 11117
  109. ' Unable to delete palette.
  110. Global Const ERR_DELPAL = 11121
  111. ' Unable to delete bitmap.
  112. Global Const ERR_DELBMP = 11118
  113. ' Unable to select palette.
  114. Global Const ERR_DELMEMDC = 11119
  115.  
  116. Sub pause (interval As Single)  'Interval = length of pause in seconds
  117. Dim StartTime As Single
  118.  
  119.     StartTime = Timer
  120.  
  121.     Do While Timer < StartTime + interval
  122.     Loop
  123.  
  124. End Sub
  125.  
  126. '--------------------------------------------------------------------------
  127. ' PrintClient256:
  128. '  - Prints the client area of a form passed to it.
  129. '  - Renders 256-color bitmaps as they appear on the form.
  130. '  - Adjusts output to the size and orientation of the printer's page.
  131. '    - ensures a .5" border on top and a minimum 1" border on bottom
  132. '    - centers width wise with a minimum .5" border
  133. '  - Calls StretchFormToDC to copy the contents of the form to the printer.
  134. '  - Starts and ends a print job.
  135. '
  136. ' frmSrc:
  137. '  - The form object to print
  138. '
  139. 'Errors
  140. ' - Displays a message box for StrechFormToDC errors.
  141. ' - Otherwise, there is no error trapping.
  142. '
  143. '--------------------------------------------------------------------------
  144. Sub PrintClient256 (frmSrc As Form)
  145.  
  146.    Dim hDCWindow As Integer
  147.    Dim WindowWidth As Integer
  148.    Dim WindowHeight As Integer
  149.    Dim WindowRatio As Double
  150.    Dim PrinterWindowWidth As Integer
  151.    Dim PrinterWindowHeight As Integer
  152.    Dim PrinterRatio As Double
  153.    Dim PixelsPerInchX As Integer
  154.    Dim PixelsPerInchY As Integer
  155.    Dim LehtBorder As Integer
  156.    Dim r
  157.  
  158.  
  159.    ' Setup form.
  160.    frmSrc.ScaleMode = PIXELS ' All dimensions must be in pixels.
  161.    hDCWindow = frmSrc.hDC    ' hDC of client area
  162.    WindowWidth = frmSrc.ScaleWidth
  163.    WindowHeight = frmSrc.ScaleHeight
  164.    WindowRatio = (WindowWidth * screen.TwipsPerPixelX) / (WindowHeight * screen.TwipsPerPixelY)
  165.  
  166.    ' Setup printer.
  167.    printer.ScaleMode = PIXELS
  168.    printer.Print ""; ' Start print job; initialize printer object.
  169.    PrinterRatio = (printer.ScaleWidth * printer.TwipsPerPixelX) / (printer.ScaleHeight * printer.TwipsPerPixelY)
  170.  
  171.    ' Scale the output to the page size.
  172.    PixelsPerInchX = 1440 \ printer.TwipsPerPixelX  'no pixels per inch in X direction
  173.    PixelsPerInchY = 1440 \ printer.TwipsPerPixelY  'no pixels per inch in Y direction
  174.    If WindowRatio >= PrinterRatio Then
  175.       PrinterWindowWidth = printer.ScaleWidth - PixelsPerInchX  ' subtract for borders
  176.       PrinterWindowHeight = ((PrinterWindowWidth * printer.TwipsPerPixelX) / (WindowRatio * printer.TwipsPerPixelY)) - (1.5 * PixelsPerInchX)
  177.       PrinterWindowWidth = (PrinterWindowHeight * printer.TwipsPerPixelY * WindowRatio) / printer.TwipsPerPixelX
  178.    Else
  179.       PrinterWindowHeight = printer.ScaleHeight - (1.5 * PixelsPerInchY) ' subtract for borders
  180.       PrinterWindowWidth = (PrinterWindowHeight * printer.TwipsPerPixelY * WindowRatio) / printer.TwipsPerPixelX
  181.    End If
  182.    LeftBorder = (printer.ScaleWidth - PrinterWindowWidth) \ 2
  183.  
  184.    ' Print the client area.
  185.    On Error Resume Next
  186.    Call StretchFormToDC(CInt(printer.hDC), LeftBorder, PixelsPerInchY \ 2, PrinterWindowWidth, PrinterWindowHeight, hDCWindow, 0, 0, WindowWidth, WindowHeight)
  187.    If Err Then
  188.       MsgBox Err & ": Error Printing Client Area"
  189.       ' Predefined error codes are commented in the general declarations.
  190.    End If
  191.    On Error GoTo 0
  192.  
  193.    ' End the print job.
  194.    printer.EndDoc
  195.  
  196.  
  197. End Sub
  198.  
  199. '--------------------------------------------------------------------------
  200. ' PrintForm256:
  201. '  - Prints the entire form.
  202. '  - Renders 256-color bitmaps as they appear on the form.
  203. '  - Adjusts output to the size and orientation of the printer's page.
  204. '    - ensures a .5" border on top and a minimum 1" border on bottom
  205. '    - centers width wise with a minimum .5" border
  206. '  - Calls StretchFormToDC to copy the contents of the form to the printer.
  207. '  - Starts and ends a print job.
  208. '
  209. ' frmSrc:
  210. '  - The form object to print.
  211. '
  212. ' Errors:
  213. '  - A message box is displayed for StrechFormToDC errors.
  214. '  - Otherwise, ther is no error trapping.
  215. '
  216. '--------------------------------------------------------------------------
  217. '
  218. Sub PrintForm256 (frmSrc As Form)
  219.    Dim RectWindow As RECT
  220.    Dim hDCWindow As Integer
  221.    Dim WindowWidth As Integer
  222.    Dim WindowHeight As Integer
  223.    Dim WindowRatio As Double
  224.    Dim PrinterWindowWidth As Integer
  225.    Dim PrinterWindowHeight As Integer
  226.    Dim PrinterRatio As Double
  227.    Dim PixelsPerInchX As Integer
  228.    Dim PixelsPerInchY As Integer
  229.    Dim LeftBorder As Integer
  230.    Dim r
  231.  
  232.  
  233.    ' Setup form.
  234.    hDCWindow = GetWindowDC(frmSrc.hWnd) ' hDC of form, including borders
  235.    r = GetWindowRect(frmSrc.hWnd, RectWindow)
  236.    WindowWidth = Abs(RectWindow.Right - RectWindow.Left)
  237.    WindowHeight = Abs(RectWindow.Bottom - RectWindow.Top)
  238.    WindowRatio = (WindowWidth * screen.TwipsPerPixelX) / (WindowHeight * screen.TwipsPerPixelY)
  239.  
  240.    ' Setup printer.
  241.    printer.ScaleMode = PIXELS
  242.    printer.Print ""; ' Start print job; initialize printer object.
  243.    PrinterRatio = (printer.ScaleWidth * printer.TwipsPerPixelX) / (printer.ScaleHeight * printer.TwipsPerPixelY)
  244.  
  245.    ' Scale the output to the page size.
  246.    PixelsPerInchX = 1440 \ printer.TwipsPerPixelX  'no pixels per inch in X direction
  247.    PixelsPerInchY = 1440 \ printer.TwipsPerPixelY  'no pixels per inch in Y direction
  248.    If WindowRatio >= PrinterRatio Then
  249.       PrinterWindowWidth = printer.ScaleWidth - PixelsPerInchX  ' subtract for borders
  250.       PrinterWindowHeight = ((PrinterWindowWidth * printer.TwipsPerPixelX) / (WindowRatio * printer.TwipsPerPixelY)) - (1.5 * PixelsPerInchX)
  251.       PrinterWindowWidth = (PrinterWindowHeight * printer.TwipsPerPixelY * WindowRatio) / printer.TwipsPerPixelX
  252.    Else
  253.       PrinterWindowHeight = printer.ScaleHeight - (1.5 * PixelsPerInchY) ' subtract for borders
  254.       PrinterWindowWidth = (PrinterWindowHeight * printer.TwipsPerPixelY * WindowRatio) / printer.TwipsPerPixelX
  255.    End If
  256.    LeftBorder = (printer.ScaleWidth - PrinterWindowWidth) \ 2
  257.  
  258.    ' Print the form.
  259.    On Error Resume Next
  260.    Call StretchFormToDC(CInt(printer.hDC), LeftBorder, PixelsPerInchY \ 2, PrinterWindowWidth, PrinterWindowHeight, hDCWindow, 0, 0, WindowWidth, WindowHeight)
  261.    If Err Then
  262.       MsgBox Err & ": Error Printing Form"
  263.       ' Predefined error codes are commented in the general declarations.
  264.    End If
  265.    On Error GoTo 0
  266.  
  267.    ' Clean up.
  268.    r = ReleaseDC(frmSrc.hWnd, hDCWindow) ' Free DC.
  269.  
  270.    ' End print job.
  271.    printer.EndDoc
  272.  
  273.  
  274. End Sub
  275.  
  276. Sub ShowBMP (ImgDir As String, ImgControl As Control, ImgFileName As String)
  277.  
  278.     ImgControl.Visible = False
  279.     ImgControl.Stretch = False
  280.     ImgControl.Top = 0
  281.     ImgControl.Left = 0
  282.     If Mid$(ImgDir, Len(ImgDir), 1) = "\" Then
  283.         ImgDir = Mid$(ImgDir, 1, Len(ImgDir) - 1)
  284.     End If
  285.     ImgControl.Picture = LoadPicture(ImgDir & "\" & ImgFileName)
  286.     frmViewer.Width = ImgControl.Width + OffsetX
  287.     frmViewer.Height = ImgControl.Height + OffsetY
  288.     If frmViewer.Width > screen.Width Then
  289.         psw1% = ImgControl.Width
  290.         ImgControl.Width = screen.Width - 1000
  291.         ImgControl.Height = (ImgControl.Width * ImgControl.Height \ psw1%)
  292.         ImgControl.Stretch = True
  293.         frmViewer.Width = ImgControl.Width + OffsetX
  294.         frmViewer.Height = ImgControl.Height + OffsetY
  295.     End If
  296.     If frmViewer.Height > screen.Height Then
  297.         psh1% = ImgControl.Height
  298.         ImgControl.Height = screen.Height - 1000
  299.         ImgControl.Width = (ImgControl.Height * ImgControl.Width \ psh1%)
  300.         ImgControl.Stretch = True
  301.         frmViewer.Width = ImgControl.Width + OffsetX
  302.         frmViewer.Height = ImgControl.Height + OffsetY
  303.     End If
  304.     frmViewer.Move (screen.Width - frmViewer.Width) \ 2, (screen.Height - frmViewer.Height) \ 2
  305.     frmViewer.Caption = UCase$(ImgFileName)
  306.     ImgControl.Visible = True
  307.  
  308. End Sub
  309.  
  310. '--------------------------------------------------------------------------
  311. ' StretchFormToDC
  312. '  - Stretches a specified portion of a form to a device context.
  313. '  - Works with 256 colors.
  314. '  - Works on PostScript and PCL printers (driver must support
  315. '    StretchDIBits).
  316. '  - Allows you to output to other device contexts
  317. '
  318. ' hDCDest:
  319. '  - Destination device context.
  320. '  - ScaleMode of device context must be pixels.
  321. '  - If using Printer object, the printer should be initialized. This can
  322. '    be accomplished with Printer.Print ""; or any other printing.
  323. '
  324. ' LeftDest, TopDest, WidthDest, HeightDest:
  325. '  - Describe the location and size of the image on the printer in pixels.
  326. '
  327. ' hDCSrc:
  328. '  - The source device context; should be from a form.
  329. '
  330. ' LeftSrc, TopSrc, WidthSrc, HeightSrc:
  331. '  - Describe the location and size of the source image in pixels.
  332. '
  333. ' Errors:
  334. '  - Errors with a predefined code if necessary.
  335. '
  336. '--------------------------------------------------------------------------
  337. Sub StretchFormToDC (hDCDest As Integer, LeftDest, TopDest, WidthDest, HeightDest, hDCSrc As Integer, LeftSrc, TopSrc, WidthSrc, HeightSrc)
  338. Dim BMI As BITMAPINFO
  339. Dim hMem As Integer
  340. Dim lpBits As Long
  341. Dim r As Integer
  342. Dim hDCMemory As Integer
  343. Dim hBmp As Integer
  344. Dim hBmpPrev As Integer
  345. Dim hPal As Integer
  346. Dim hPalPrev As Integer
  347. Dim RasterCapsDest As Integer
  348. Dim RasterCapsSrc As Integer
  349. Dim HasPaletteSrc As Integer
  350. Dim BitsPixelSrc As Integer
  351. Dim PlanesSrc As Integer
  352. Dim PaletteSizeSrc As Integer
  353. Dim LogPal As LOGPALETTE
  354.  
  355.    ' Set error trap.
  356.    On Error GoTo SFTDC_ERRORS:
  357.  
  358.    ' Check that destination supports StretchDIBits.
  359.    RasterCapsDest = GetDeviceCaps(hDCDest, RASTERCAPS)
  360.    If RasterCapsDest And RC_STRETCHDIB <> RC_STRETCHDIB Then
  361.       Error ERR_DEVSTRETCHDIB
  362.    End If
  363.  
  364.    ' Get properties of source device context.
  365.    RasterCapsSrc = GetDeviceCaps(hDCSrc, RASTERCAPS)
  366.    HasPaletteSrc = RasterCapsSrc And RC_PALETTE
  367.    BitsPixelSrc = GetDeviceCaps(hDCSrc, BITSPIXEL)
  368.    PlanesSrc = GetDeviceCaps(hDCSrc, PLANES)
  369.    PaletteSizeSrc = GetDeviceCaps(hDCSrc, SIZEPALETTE)
  370.  
  371.    ' Limit function use to 256-color palettes.
  372.    If HasPaletteSrc And (PaletteSizeSrc <> 256) Then Error ERR_PALSIZE
  373.  
  374.    ' Copy source to a bitmap in memory.
  375.    hDCMemory = CreateCompatibleDC(hDCSrc)
  376.    If hDCMemory = 0 Then Error ERR_CREATEMEMDC
  377.    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
  378.    If hBmp = 0 Then Error ERR_CREATEBMP
  379.    hBmpPrev = SelectObject(hDCMemory, hBmp)
  380.    ' Create a copy of the system palette and realize it if necessary.
  381.    If HasPaletteSrc Then
  382.       LogPal.palVersion = &H300
  383.       LogPal.palNumEntries = 256
  384.       r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
  385.       If r = 0 Then Error ERR_GETPALETTE
  386.       hPal = CreatePalette(LogPal)
  387.       If hPal = 0 Then Error ERR_CREATEPAL
  388.       ' Select the palette into the destination and realize it.
  389.       hPalPrev = SelectPalette(hDCMemory, hPal, 0)
  390.       r = RealizePalette(hDCMemory)
  391.    End If
  392.    ' Copy the bitmap to the memory-device context.
  393.    r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, SRCCOPY)
  394.    If r = 0 Then Error ERR_BITBLT
  395.    hBmp = SelectObject(hDCMemory, hBmpPrev)
  396.  
  397.    ' Fill in necessary parts of bitmap info.
  398.    BMI.bmiHeader.biSize = 40
  399.    BMI.bmiHeader.biWidth = WidthSrc
  400.    BMI.bmiHeader.biHeight = HeightSrc
  401.    BMI.bmiHeader.biPlanes = 1
  402.    If BitsPixelSrc * PlanesSrc = 24 Then
  403.       ' 24-bit True color may require too much memory so
  404.       ' limit to 256-color DIB.
  405.       ' You can get rid of this exception and the routine
  406.       ' should copy 24-bit color bitmaps.
  407.       BMI.bmiHeader.biBitCount = 8 ' 8 bits = 256 colors
  408.    Else
  409.       BMI.bmiHeader.biBitCount = BitsPixelSrc * PlanesSrc
  410.    End If
  411.    BMI.bmiHeader.biCompression = BI_RGB
  412.  
  413.    ' Allocate memory for bitmap bits.
  414.    hMem = GlobalAlloc(GMEM_MOVEABLE, (CLng(WidthSrc * BMI.bmiHeader.biBitCount + 31) \ 32) * 4 * HeightSrc)
  415.    If hMem = 0 Then Error ERR_BITMEM
  416.    lpBits = GlobalLock(hMem)
  417.  
  418.    ' Get the bits and color information from the bitmap.
  419.    r = GetDIBits(hDCMemory, hBmp, 0, HeightSrc, lpBits, BMI, DIB_RGB_COLORS)
  420.  
  421.    If r = 0 Then Error ERR_GETDIB
  422.  
  423.    ' Stretch the device-independent bitmap to the printer.
  424.    r = StretchDIBits(hDCDest, LeftDest, TopDest, WidthDest, HeightDest, 0, 0, WidthSrc, HeightSrc, lpBits, BMI, DIB_RGB_COLORS, SRCCOPY)
  425.    If r = 0 Then Error ERR_STRETCHDIB
  426.  
  427.    ' Free up memory used for bitmap bits.
  428.    r = GlobalUnlock(hMem)
  429.    If r <> 0 Then Error ERR_UNLOCKMEM
  430.    r = GlobalFree(hMem)
  431.    If r <> 0 Then Error ERR_FREEMEM
  432.  
  433.    ' Select the default palette back if necessary.
  434.    If HasPaletteSrc Then
  435.       r = SelectPalette(hDCMemory, hPalPrev, 0)
  436.       If r = 0 Then Error ERR_SELPAL
  437.       r = DeleteObject(hPal)
  438.       If r = 0 Then Error ERR_DELPAL
  439.    End If
  440.  
  441.    ' Delete created objects.
  442.    r = DeleteObject(hBmp)
  443.    If r = 0 Then Error ERR_DELBMP
  444.    r = DeleteDC(hDCMemory)
  445.    If r = 0 Then Error ERR_DELMEMDC
  446.  
  447.    On Error GoTo 0
  448. Exit Sub
  449.  
  450. ' Clean up predefined errors if necessary.
  451. SFTDC_ERRORS:
  452.    Select Case Err
  453.       Case ERR_CREATEBMP
  454.          r = DeleteDC(hDCMemory)
  455.          Error Err
  456.       Case ERR_GETPALETTE, ERR_CREATEPAL
  457.          hBmp = SelectObject(hDCMemory, hBmpPrev)
  458.          r = DeleteObject(hBmp)
  459.          r = DeleteDC(hDCMemory)
  460.          Error Err
  461.       Case ERR_BITBLT
  462.          If HasPaletteSrc Then
  463.             r = SelectPalette(hDCMemory, hPalPrev, 0)
  464.             r = DeleteObject(hPal)
  465.          End If
  466.          hBmp = SelectObject(hDCMemory, hBmpPrev)
  467.          r = DeleteObject(hBmp)
  468.          r = DeleteDC(hDCMemory)
  469.          Error Err
  470.       Case ERR_BITMEM
  471.          If HasPaletteSrc Then
  472.             r = SelectPalette(hDCMemory, hPalPrev, 0)
  473.             r = DeleteObject(hPal)
  474.          End If
  475.          r = DeleteObject(hBmp)
  476.          r = DeleteDC(hDCMemory)
  477.          Error Err
  478.       Case ERR_GETDIB, ERR_STRETCHDIB
  479.          r = GlobalUnlock(hMem)
  480.          r = GlobalFree(hMem)
  481.          If HasPaletteSrc Then
  482.             r = SelectPalette(hDCMemory, hPalPrev, 0)
  483.             r = DeleteObject(hPal)
  484.          End If
  485.          r = DeleteObject(hBmp)
  486.          r = DeleteDC(hDCMemory)
  487.          Error Err
  488.       Case ERR_UNLOCKMEM, ERR_FREEMEM
  489.          If HasPaletteSrc Then
  490.             r = SelectPalette(hDCMemory, hPalPrev, 0)
  491.             r = DeleteObject(hPal)
  492.          End If
  493.          r = DeleteObject(hBmp)
  494.          r = DeleteDC(hDCMemory)
  495.          Error Err
  496.       Case ERR_SELPAL, ERR_DELPAL
  497.          r = DeleteObject(hBmp)
  498.          r = DeleteDC(hDCMemory)
  499.          Error Err
  500.       Case ERR_DELBMP
  501.          r = DeleteDC(hDCMemory)
  502.          Error Err
  503.       Case Else
  504.          Error Err
  505.    End Select
  506.    Error Err
  507.  
  508. End Sub
  509.  
  510.